home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / tcsel003.zip / KEYINPUT.PAS < prev    next >
Pascal/Delphi Source File  |  1992-11-15  |  18KB  |  527 lines
  1. {$IFDEF Ver60}
  2. {$A+,B-,D+,E+,F-,I-,L+,N+,O-,R-,S-,V-,X+}
  3. {$ELSE}
  4. {$A+,B-,D+,E+,F-,I-,L+,N+,O-,R-,S-,V-}
  5. {$ENDIF}
  6.  
  7. unit keyinput;
  8.  
  9. { Author Trevor J Carlsen - released into the public domain 1991         }
  10. {        PO Box 568                                                      }
  11. {        Port Hedland                                                    }
  12. {        Western Australia 6721                                          }
  13. {        Voice +61 91 73 2026  Data +61 91 73 2930                       }
  14. {        FidoNet 3:690/644                                               }
  15.  
  16. { This unit is designed to permit controlled input into a pre-determined }
  17. { field size.  It also provides some handy associated procedures and     }
  18. { functions and constants.                                               }
  19.  
  20. interface
  21.  
  22. uses crt;
  23.  
  24. const  { These are the values returned by the function ReadWord }
  25.   F1  = $3b00; ShF1  = $5400; CtrlF1  = $5e00; AltF1  = $6800;
  26.   F2  = $3c00; ShF2  = $5500; CtrlF2  = $5f00; AltF2  = $6900;
  27.   F3  = $3d00; ShF3  = $5600; CtrlF3  = $6000; AltF3  = $6a00;
  28.   F4  = $3e00; ShF4  = $5700; CtrlF4  = $6100; AltF4  = $6b00;
  29.   F5  = $3f00; ShF5  = $5800; CtrlF5  = $6200; AltF5  = $6c00;
  30.   F6  = $4000; ShF6  = $5900; CtrlF6  = $6300; AltF6  = $6d00;
  31.   F7  = $4100; ShF7  = $5a00; CtrlF7  = $6400; AltF7  = $6e00;
  32.   F8  = $4200; ShF8  = $5b00; CtrlF8  = $6500; AltF8  = $6f00;
  33.   F9  = $4300; ShF9  = $5c00; CtrlF9  = $6600; AltF9  = $7000;
  34.   F10 = $4400; ShF10 = $5d00; CtrlF10 = $6700; AltF10 = $7100;
  35.  
  36.   BackSpace    = $0e08; CtrlBackSpace = $0e7f;
  37.   Tab          = $0f09; Tab_left      = $0f00;
  38.   Enter        = $1c0d; CtrlEnter     = $1c0a;
  39.   InsertKey    = $5200; DeleteKey     = $5300;
  40.   Home         = $4700; CtrlHome      = $7700;
  41.   Endkey       = $4f00; CtrlEnd       = $7500;
  42.   PageUp       = $4900; CtrlPageUp    = $8400;
  43.   PageDn       = $5100; CtrlPageDown  = $7600;
  44.   UpArrow      = $4800; DownArrow     = $5000;
  45.   LeftArrow    = $4b00; CtrlLeftArrow = $7300;
  46.   RightArrow   = $4d00; CtrlRightArrow= $7400;
  47.   Escape       = $011b;
  48.  
  49. type
  50.   Toggles      = (RightShift, LeftShift, Ctrl, Alt,
  51.                   ScrollLock, NumLock, CapsLock, Insert);
  52.   shiftstatus  = set of Toggles;
  53.   CursorState  = (Off, On, Normal, Block);
  54.   ToggleType   = Off..On;
  55.   InputType    = (Numeric, AlphaNumeric);
  56.  
  57. const
  58.   ReverseColour: boolean = false;{ The input field will be the default attr }
  59.                                  { in reverse                               }
  60.   InsertOn     : boolean = false;
  61.   ExitKey      : word    = 0;
  62.   DecimalPts   : byte    = 2;
  63. var
  64.   FieldColour : byte;
  65.   KbdStatus   : shiftstatus absolute $40:$17;
  66.   ValidKeys: array[InputType] of set of char;
  67.  
  68. procedure Beep(freq,len: word);
  69. function  CursorStatus: CursorState;
  70. procedure Cursor(Action: CursorState);
  71. procedure NormalCursor;
  72. procedure HiddenCursor;
  73. procedure BlockCursor;
  74. procedure ClearKbdBuffer;
  75. function KeyWord: word;
  76. function  ReadStr(width   : word;
  77.                   prompt  : string;
  78.                   s       : string;
  79.                   _Input  : InputType) : string;
  80. function  ReadInteger(p: string; min,max,I: longint): longint;
  81. function  ReadReal(p: string; min,max: longint; R: real): real;
  82. function ReadExtended(p: string; min,max: longint; R: Extended): Extended;
  83. procedure SetLock(TKey: Toggles; state: ToggleType);
  84. function  LeftShiftPressed: boolean;
  85. function  RightShiftPressed: boolean;
  86. function  AltPressed: boolean;
  87. function  CtrlPressed: boolean;
  88.  
  89. implementation
  90.  
  91. var
  92.   OriginalStatus : CursorState;
  93.   OldExitProc    : pointer;
  94.  
  95.  
  96. procedure Beep(freq,len : word);
  97.   { Beeps the speaker for len thousandths of a second }
  98.   begin
  99.     Sound(freq);
  100.     delay(len);
  101.     NoSound;
  102.   end;  { Beep }
  103.  
  104. function CursorStatus: CursorState;
  105.   { Check the current status of the cursor and assigns it a value }
  106.   var
  107.     bottom: byte absolute $40:$60;
  108.     top   : byte absolute $40:$61;
  109.     x     : shortint;
  110.   begin
  111.     x     := bottom - top;
  112.     if x < 0 then
  113.       CursorStatus := Off
  114.     else if x = 1 then
  115.       CursorStatus := Normal
  116.     else if x > 1 then
  117.       CursorStatus := Block
  118.     else CursorStatus := On;
  119.   end;  { CursorStatus }
  120.  
  121. procedure Cursor(Action : CursorState);
  122.   { Turn the cursor on/off or make it a block}
  123.  
  124.   procedure ChangeCursor(top,bottom : byte); assembler;
  125.       asm
  126.         mov ah, $01
  127.         mov ch, top
  128.         mov cl, bottom
  129.         int $10
  130.       end;
  131.  
  132. begin
  133.   case action of
  134.     On     : if LastMode = Mono then
  135.                ChangeCursor($0C,$0C)
  136.              else
  137.                ChangeCursor($06,$06);
  138.     Normal : if LastMode = Mono then
  139.                ChangeCursor($0B,$0C)
  140.              else
  141.                ChangeCursor($06,$07);
  142.     Off    : ChangeCursor($20,$00);
  143.     Block  : if LastMode = Mono then
  144.                ChangeCursor($02,$0C)
  145.              else
  146.                ChangeCursor($02,$07);
  147.   end; { case}
  148. end;  { ChangeCursor}
  149.  
  150. procedure NormalCursor;
  151.   begin
  152.     Cursor(On);
  153.   end; { NormalCursor }
  154.  
  155. procedure HiddenCursor;
  156.   begin
  157.     Cursor(Off);
  158.   end; { HiddenCursor }
  159.  
  160. procedure BlockCursor;
  161.   begin
  162.     Cursor(Block);
  163.   end;  { BlockCursor }
  164.  
  165. procedure ClearKbdBuffer;
  166.   begin
  167.     {$IFDEF Ver60}
  168.     while Keypressed do ReadKey;
  169.     {$ELSE}
  170.     while KeyPressed do while ReadKey = #0 do;
  171.     {$ENDIF}
  172.   end;
  173.  
  174. function KeyWord : word; assembler;
  175.   { Returns a word value where the msb is the scan code of a keypress    }
  176.   { and the lsb is the asciiz value of the key.                          }
  177.   asm
  178.     mov  ax,0
  179.     int  16h
  180.   end;  { KeyWord }
  181.  
  182.  
  183. function  ReadStr(width   : word;
  184.                   prompt  : string;
  185.                   s       : string;
  186.                   _Input  : InputType) : string;
  187.  
  188. {   Editing keys are -                                                   }
  189. {     DeleteKey        - DeleteKeys character at the cursor.             }
  190. {     LeftArrow        - Nondestructive move cursor to the left.         }
  191. {     RightArrow       - Nondestructive move cursor to the right.        }
  192. {     End              - Move cursor to end of input string.             }
  193. {     Home             - Move cursor to start of input string.           }
  194. {     Backspace        - DeleteKeys character to the left of cursor.     }
  195. {     escape           - Aborts routine which then returns the original  }
  196. {                        data string. ExitKey will be equal to escape.   }
  197. {     return/enter     - Leaves routine with string returned. ExitKey=0  }
  198. {     Tab/TabLeft      - Leaves routine with string returned and sets    }
  199. {                        the global variable ExitKey to the key code.    }
  200. {     CursorKeys       - As per Tab/TabLeft except as above              }
  201.  
  202. {   Width = The width of the input field.  Once input reaches the width  }
  203. {           required, no further characters are accepted.                }
  204. {   prompt= A prompt will be displayed in the current attribute.  If no  }
  205. {           prompt is required pass a nul string.                        }
  206. {   attr  = The input field will be displayed in attr colour.            }
  207. {   s     = s will be displayed in the input field and the cursor will   }
  208. {           be positioned at the end of the s string.                    }
  209.  
  210. {   Example:                                                             }
  211. {      st := ReadStr(20,'Enter Name: ',st,AlphaNumeric);                 }
  212. {      ( st MUST be initialised in the above example before the call. )  }
  213.  
  214. const
  215.     space = #32;
  216. var
  217.   xpos, ypos,
  218.   stpos,OldAttr : byte;
  219.   len           : byte absolute s;
  220.   finished,
  221.   JustStarted   : boolean;
  222.   key           : word;
  223.   ch            : char absolute key;
  224.   OrigStr       : string;
  225.  
  226.   procedure WriteField;
  227.     { writes spaces to an input field }
  228.     var x : byte;
  229.     begin
  230.       GotoXY(xpos,ypos);
  231.       for x := 1 to width do
  232.         write(space);
  233.       GotoXY(xpos,ypos);
  234.     end; { WriteField }
  235.  
  236.   procedure DeleteChar;
  237.     begin
  238.       Delete(s,stpos,1);
  239.       s := s + space;
  240.       gotoXY(xpos,ypos);
  241.       write(s);
  242.       dec(len);
  243.     end;  { DeleteChar }
  244.  
  245.   procedure AddChar;
  246.     { Checks that it is valid to insert or add a character to input str }
  247.     begin
  248.       if JustStarted then begin
  249.         len   := 0;
  250.         stpos := 1;
  251.         WriteField;
  252.       end;
  253.       if InsertOn then begin
  254.         if (len < width) then begin
  255.           move(s[stpos],s[succ(stpos)],width-pred(stpos));
  256.           inc(len);
  257.           s[stpos] := ch;
  258.           inc(stpos);
  259.         end
  260.         else beep(450,15);
  261.       end else begin
  262.         if stpos <= width then begin
  263.           s[stpos] := ch;
  264.           if stpos > len then
  265.             inc(len);
  266.           inc(stpos);
  267.         end else beep(450,15);
  268.       end;
  269.     end; { AddChar }
  270.  
  271.   begin
  272.     OrigStr       := s;
  273.     ExitKey       := 0;
  274.     finished      := false;
  275.     JustStarted   := true;
  276.     OldAttr       := TextAttr;              { Save the current attribute }
  277.     write(prompt+' ');       { Write the prompt in the current attribute }
  278.     if (width + WhereX) > 79 then
  279.       writeln;
  280.     if ReverseColour then
  281.       FieldColour := (TextAttr shr 4) or ((TextAttr shl 5) shr 1);
  282.     TextAttr      := Fieldcolour; { Change the attribute for input field }
  283.     xpos          := WhereX;          { Save the current cursor position }
  284.     ypos          := WhereY;
  285.     WriteField;                                  { Clear the input field }
  286.     stpos         := 1;
  287.     repeat
  288.       GotoXY(xpos,ypos);
  289.       write(s);
  290.       GotoXY(xpos + pred(stpos),ypos);
  291.       if stpos = succ(width) then
  292.         Cursor(Off)
  293.       else if InsertOn then{ Change cursor size depending on insert mode }
  294.         Cursor(Block)
  295.       else
  296.         Cursor(Normal);
  297.       key := KeyWord;
  298.       ExitKey := key;
  299.       case key of
  300.         InsertKey  : InsertOn := not InsertOn;
  301.         DeleteKey  : if (len > 0) and (stpos > 0) then
  302.                        DeleteChar;
  303.         Enter      : begin
  304.                        ReadStr  := s;
  305.                        finished := true;
  306.                      end;
  307.         BackSpace  : if stpos > 1 then begin
  308.                        dec(stpos);
  309.                        DeleteChar;
  310.                      end
  311.                      else beep(450,15);
  312.         Escape     : begin
  313.                        finished := true;
  314.                        ReadStr  := OrigStr;
  315.                        gotoXY(xpos,ypos); write(OrigStr);
  316.                      end;
  317.         LeftArrow  : if stpos > 1 then dec(stpos);
  318.         RightArrow : if stpos <= len then inc(stpos);
  319.         Home       : stpos := 1;
  320.         EndKey     : stpos := succ(len);
  321.         Tab        : begin
  322.                        ReadStr  := s;
  323.                        finished := true;
  324.                      end
  325.         else if byte(ch) = 0 then begin
  326.           ReadStr  := s;
  327.           finished := true;
  328.         end
  329.         else if ch in ValidKeys[_Input] then
  330.           AddChar
  331.         else beep(450,15);
  332.       end; { case key of }
  333.       JustStarted := false;
  334.     until finished;
  335.     TextAttr      := OldAttr;              { Restore the old attribute }
  336.     WriteField; write(s);
  337.   end; { ReadStr }
  338.  
  339. function ReadInteger(p: string; min,max,I: longint): longint;
  340.   { Prompts for input and converts that input to a longint.  If number }
  341.   { entered is less than min or greater than max, will beep and await  }
  342.   { re-entry of the data.                                              }
  343.   { Example:                                                           }
  344.   { L := ReadInteger('Enter number between 10 and 100: ',10,100,Numb); }
  345.   var
  346.     temp     : longint;
  347.     code     : integer;
  348.     finished : boolean;
  349.     st       : string;
  350.     col,row,Icol,
  351.     W        : byte;
  352.   begin
  353.     col := WhereX; row := WhereY; Icol := col + succ(length(p));
  354.     if min >= 0 then
  355.       ValidKeys[Numeric] := ['0'..'9']
  356.     else
  357.       ValidKeys[Numeric] := ['0'..'9','-'];
  358.     repeat
  359.       str(max,st); W := length(st) + 1;
  360.       str(min,st);
  361.       if (length(st) + 1) > W then
  362.         W := length(st) + 1;
  363.       gotoXY(col,row);
  364.       str(I, st);
  365.       st := ReadStr(W,p,st,Numeric);
  366.       val(st,temp,code);
  367.       finished := ((code = 0) and (temp >= min) and (temp <= max)) or
  368.                   (ExitKey = escape) or (ExitKey = F10);
  369.       if not finished then
  370.         Beep(400,250)
  371.       else if code = 0 then begin
  372.         ReadInteger := temp;
  373.         gotoXY(Icol,row);
  374.         write(temp:W);
  375.       end else begin
  376.         ReadInteger := I;
  377.         gotoXY(Icol,row);
  378.         write(I:W);
  379.       end;
  380.     until finished;
  381.   end;  { ReadInteger }
  382.  
  383. function ReadReal(p: string; min,max: longint; R: real): real;
  384.   { Prompts for input and converts that input to a real.  If number    }
  385.   { entered is less than min or greater than max, will beep and await  }
  386.   { re-entry of the data.                                              }
  387.   { Example:                                                           }
  388.   { R := ReadInteger('Enter number between 10 and 100: ',10,100,Numb); }
  389.  
  390.   var
  391.     temp     : real;
  392.     code     : integer;
  393.     finished : boolean;
  394.     st       : string;
  395.     col,row,Icol,
  396.     W        : byte;
  397.   begin
  398.     col := WhereX; row := WhereY; Icol := col + succ(length(p));
  399.     str(max,st); W := length(st) + DecimalPts + 1;
  400.     str(min,st);
  401.     if (length(st) + DecimalPts + 1) > W then
  402.       W := length(st) + DecimalPts + 1;
  403.     if min >= 0 then
  404.       ValidKeys[Numeric] := ['0'..'9','.']
  405.     else
  406.       ValidKeys[Numeric] := ['0'..'9','-','.'];
  407.     repeat
  408.       str(R:0:DecimalPts,st); gotoXY(col,row);
  409.       st := ReadStr(11,p,st,Numeric);
  410.       val(st,temp,code);
  411.       finished := ((code = 0) and (temp >= min) and (temp <= max)) or
  412.                   (ExitKey = escape) or (ExitKey = F10);
  413.       if not finished then
  414.         Beep(400,250)
  415.       else if (code = 0) then begin
  416.         ReadReal := temp;
  417.         gotoXY(Icol,row);
  418.         write(temp:W:DecimalPts);
  419.       end else begin
  420.         gotoXY(Icol,row);
  421.         write(R:W:DecimalPts);
  422.         ReadReal := R;
  423.       end;
  424.     until finished;
  425.   end;  { ReadReal }
  426.  
  427. function ReadExtended(p: string; min,max: longint; R: Extended): Extended;
  428.   { Prompts for input and converts that input to a Extended. If number }
  429.   { entered is less than min or greater than max, will beep and await  }
  430.   { re-entry of the data.                                              }
  431.   { Example:                                                           }
  432.   { R := ReadInteger('Enter number between 10 and 100: ',10,100,Numb); }
  433.  
  434.   var
  435.     temp     : Extended;
  436.     code     : integer;
  437.     finished : boolean;
  438.     st       : string;
  439.     col,row,Icol,
  440.     W        : byte;
  441.   begin
  442.     col := WhereX; row := WhereY; Icol := col + succ(length(p));
  443.     str(max,st); W := length(st) + DecimalPts + 1;
  444.     str(min,st);
  445.     if (length(st) + DecimalPts + 1) > W then
  446.       W := length(st) + DecimalPts + 1;
  447.     if min >= 0 then
  448.       ValidKeys[Numeric] := ['0'..'9','.']
  449.     else
  450.       ValidKeys[Numeric] := ['0'..'9','-','.'];
  451.     repeat
  452.       str(R:0:DecimalPts,st);  gotoXY(col,row);
  453.       st := ReadStr(W,p,st,Numeric);
  454.       val(st,temp,code);
  455.       finished := ((code = 0) and (temp >= min) and (temp <= max)) or
  456.                   (ExitKey = escape) or (ExitKey = F10);
  457.       if not finished then
  458.         Beep(400,250)
  459.       else if (code = 0) then begin
  460.         ReadExtended := temp;
  461.         gotoXY(Icol,row);
  462.         write(temp:W:DecimalPts);
  463.       end else begin
  464.         gotoXY(Icol,row);
  465.         write(R:W:DecimalPts);
  466.         ReadExtended := R;
  467.       end;
  468.     until finished;
  469.   end;  { ReadExtended }
  470.  
  471.  
  472. procedure SetLock(TKey: Toggles; state: ToggleType);
  473.   { Sets the status of the various keyboard toggle locks.  On older XTs  }
  474.   { this may not cause the keyboard LED indicators to change.            }
  475.   begin
  476.     case TKey of
  477.     CapsLock  : if state = On then
  478.                   KbdStatus := KbdStatus + [CapsLock]
  479.                 else
  480.                   KbdStatus := KbdStatus - [CapsLock];
  481.     NumLock  : if state = On then
  482.                   KbdStatus := KbdStatus + [NumLock]
  483.                 else
  484.                   KbdStatus := KbdStatus - [NumLock];
  485.     ScrollLock: if state = On then
  486.                   KbdStatus := KbdStatus + [ScrollLock]
  487.                 else
  488.                   KbdStatus := KbdStatus - [ScrollLock];
  489.     end; { case }
  490.   end;
  491.  
  492. function  LeftShiftPressed: boolean;
  493.   begin
  494.     LeftShiftPressed := LeftShift in KbdStatus;
  495.   end;
  496.  
  497. function  RightShiftPressed: boolean;
  498.   begin
  499.     RightShiftPressed := RightShift in KbdStatus;
  500.   end;
  501.  
  502. function  AltPressed: boolean;
  503.   begin
  504.     AltPressed := Alt in KbdStatus;
  505.   end;
  506.  
  507. function  CtrlPressed: boolean;
  508.   begin
  509.     CtrlPressed := Ctrl in KbdStatus;
  510.   end;
  511.  
  512. procedure KbdExitProc; far;
  513.   begin
  514.     ExitProc := OldExitProc;
  515.     Cursor(OriginalStatus);   { Restore the cursor to the original state }
  516.   end;  { KbdExitProc }
  517.  
  518. begin
  519.   ValidKeys[AlphaNumeric] := [#0..#255];
  520.   FieldColour := TextAttr;
  521.   { Set up an exit procedure to ensure that the cursor is restored when  }
  522.   { when the program terminates (however that may occur!)                }
  523.   OldExitProc    := ExitProc;
  524.   OriginalStatus := CursorStatus;
  525. end.
  526.  
  527.